home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
Dev
/
Oberon
/
source
/
ProjectOberon
/
Display.mod
< prev
next >
Wrap
Text File
|
1995-07-02
|
14KB
|
512 lines
(*************************************************************************
$RCSfile: Display.mod $
Description: Clone of the Project Oberon Display module.
Interface based on module Display for Ceres Oberon System.
NW 3.3.89 / 19.1.91 / 22.11.92
Created by: fjc (Frank Copeland)
$Revision: 1.2 $
$Author: fjc $
$Date: 1995/06/04 23:24:07 $
Copyright © 1995, Frank Copeland.
This file is part of the Oberon-A Library.
See Oberon-A.doc for conditions of use and distribution.
*************************************************************************)
<*STANDARD-*>
MODULE Display;
IMPORT
SYS := SYSTEM, Kernel, Errors, e := Exec, d := Dos, gfx := Graphics,
as := AmigaSupport;
CONST
black* = 0; white* = 1;
replace* = 0; paint* = 1; invert* = 2;
TYPE
Frame* = POINTER TO FrameDesc;
FrameMsg* = RECORD END;
Pattern* = LONGINT;
PatternPtr = POINTER [1] TO PatternDesc;
Font* = POINTER TO Bytes;
Cache = RECORD
dx, x, y, w, h : INTEGER;
pat : PatternPtr;
END;
Bytes* = RECORD
textFont *: gfx.TextFontPtr;
cache : ARRAY 256 OF Cache;
END;
Handler* = PROCEDURE (f: Frame; VAR msg: FrameMsg);
FrameDesc* = RECORD
dsc*, next*: Frame;
X*, Y*, W*, H*: INTEGER;
handle*: Handler
END;
VAR
Unit*: LONGINT; (*RasterUnit = Unit/36000 mm*)
Left*, ColLeft*, Bottom*, UBottom*, Width*, Height*: INTEGER;
arrow*, star*, hook*, cross*, downArrow*: Pattern;
grey0*, grey1*, grey2*, ticks*: Pattern;
CONST
replaceTerm = -40H;
paintTerm = -10H;
invertTerm = -40H;
TYPE
PatternDesc = RECORD [1]
w, h, W : INTEGER;
raster : gfx.PLANEPTR;
next : PatternPtr;
END; (* PatternDesc *)
VAR
patterns : PatternPtr;
PROCEDURE Round16 ( x : INTEGER ) : INTEGER;
BEGIN INC (x, 15); RETURN x - (x MOD 16)
END Round16;
PROCEDURE Round32 ( x : INTEGER ) : INTEGER;
BEGIN INC (x, 31); RETURN x - (x MOD 32)
END Round32;
PROCEDURE MapX ( x : INTEGER ) : INTEGER;
BEGIN RETURN x + as.win.borderLeft
END MapX;
PROCEDURE MapY ( y : INTEGER ) : INTEGER;
BEGIN RETURN as.win.height - as.win.borderBottom - y - 1
END MapY;
PROCEDURE Map* ( X : INTEGER ) : LONGINT;
BEGIN RETURN 0
END Map;
PROCEDURE SetMode* ( X : INTEGER; s : SET );
BEGIN
END SetMode;
PROCEDURE SetColor* ( col, red, green, blue : INTEGER );
(*col < 0: overlay color*)
BEGIN
as.BeginUpdate;
gfx.SetRGB4 ( SYS.ADR (as.scr.viewPort), ABS (col),
SHORT (red), SHORT (green), SHORT (blue));
as.EndUpdate;
END SetColor;
PROCEDURE GetColor* ( col : INTEGER; VAR red, green, blue : INTEGER );
VAR color : INTEGER;
BEGIN
as.BeginUpdate;
color := gfx.GetRGB4 (as.scr.viewPort.colorMap, col);
red := SYS.LSH (color, -8) MOD 16;
green := SYS.LSH (color, -4) MOD 16;
blue := color MOD 16;
as.EndUpdate;
END GetColor;
PROCEDURE SetCursor* ( mode : SET );
(*color cursor; 0: crosshair, 1: arrow*)
BEGIN
END SetCursor;
PROCEDURE DefCC* ( x, y, w, h : INTEGER ); (*crosshair window*)
BEGIN
END DefCC;
PROCEDURE DefCP* (VAR raster: ARRAY OF SYS.BYTE); (*cursor pattern*)
BEGIN
END DefCP;
PROCEDURE DrawCX* ( x, y : INTEGER );
BEGIN
END DrawCX;
PROCEDURE FadeCX* ( x, y : INTEGER );
BEGIN
END FadeCX;
PROCEDURE GetChar* (*get raster data of character ch*)
( f : Font; ch : CHAR;
VAR dx, x, y, w, h : INTEGER;
VAR p : LONGINT );
TYPE
CharLoc = RECORD [1] offset, size : INTEGER END;
CharLocPtr = POINTER [1] TO ARRAY 256 OF CharLoc;
WordArray = POINTER [1] TO ARRAY 256 OF INTEGER;
VAR
tf : gfx.TextFontPtr; charLoc : CharLocPtr;
charSpace, charKern : WordArray; charData : e.APTR;
dx0, x0, y0, w0, h0, i, W : INTEGER; pat : PatternPtr;
rp : gfx.RastPort; bm : gfx.BitMap; text : ARRAY 2 OF CHAR;
BEGIN
ASSERT (f # NIL, 97);
IF f.cache[ORD(ch)].dx # 0 THEN (* Return cached values *)
dx := f.cache[ORD(ch)].dx;
x := f.cache[ORD(ch)].x;
y := f.cache[ORD(ch)].y;
w := f.cache[ORD(ch)].w;
h := f.cache[ORD(ch)].h;
p := SYS.VAL (LONGINT, f.cache[ORD(ch)].pat)
ELSE
ASSERT (f.textFont # NIL, 97); tf := f.textFont;
IF (ch >= tf.loChar) & (ch <= tf.hiChar) THEN
(* Calculate char metrics *)
charLoc := tf.charLoc; i := ORD (ch) - ORD (tf.loChar);
IF gfx.proportional IN tf.flags THEN
charSpace := tf.charSpace; charKern := tf.charKern;
dx0 := charSpace[i] + charKern[i];
w0 := charLoc[i].size + charKern[i]
ELSE
dx0 := tf.xSize; w0 := charLoc[i].size;
END;
x0 := 0; y0 := tf.baseline - tf.ySize; h0 := tf.ySize;
IF (w0 * h0) > 0 THEN
(* Create a pattern *)
NEW (pat); ASSERT (pat # NIL, 98);
W := Round16 (w0);
pat.raster := gfx.AllocRaster (W, h0);
ASSERT (pat.raster # NIL, 98);
pat.w := w0; pat.h := h0; pat.W := W;
pat.next := patterns; patterns := pat;
(* Blit the glyph data from the font to the pattern *)
gfx.InitBitMap (bm, 1, W, h0);
bm.planes[0] := pat.raster;
gfx.InitRastPort (rp);
rp.bitMap := SYS.ADR (bm);
gfx.SetAPen (SYS.ADR (rp), 1); gfx.SetBPen (SYS.ADR (rp), 0);
gfx.SetDrMd (SYS.ADR (rp), gfx.jam2); gfx.SetFont (SYS.ADR (rp), tf);
gfx.Move (SYS.ADR (rp), 0, tf.baseline);
text[0] := ch; text[1] := 0X; gfx.Text (SYS.ADR (rp), text, 1);
ELSE
pat := NIL
END;
(* Cache for next time *)
f.cache [ORD(ch)].dx := dx0;
f.cache [ORD(ch)].x := x0;
f.cache [ORD(ch)].y := y0;
f.cache [ORD(ch)].w := w0;
f.cache [ORD(ch)].h := h0;
f.cache [ORD(ch)].pat := pat;
ELSE
dx0 := 0; x0 := 0; y0 := 0; w0 := 0; h0 := 0; pat := NIL
END;
(* Return values *)
dx := dx0; x := x0; y := y0; w := w0; h := h0;
p := SYS.VAL (LONGINT, pat)
END
END GetChar;
PROCEDURE NewPattern* (VAR image : ARRAY OF SET; w, h : INTEGER): Pattern;
VAR pat : PatternPtr; W : INTEGER;
BEGIN
W := Round32 (w);
ASSERT ((LEN(image) DIV 4) <= ((W DIV 8) * h), 97);
NEW (pat); ASSERT (pat # NIL, 98);
pat.w := w; pat.h := h; pat.W := W;
pat.raster := gfx.AllocRaster (W, h); ASSERT (pat.raster # NIL, 98);
SYS.MOVE (SYS.ADR (image), pat.raster, (W DIV 8) * h);
pat.next := patterns; patterns := pat;
RETURN SYS.VAL (Pattern, pat)
END NewPattern;
(*raster operations*)
PROCEDURE CopyBlock*(sx, sy, w, h, dx, dy, mode: INTEGER);
VAR rp : gfx.RastPortPtr; term : e.UBYTE;
BEGIN
ASSERT (as.win # NIL, 97); ASSERT (mode IN {replace, paint, invert}, 97);
ASSERT ((sx >= 0) & (sx < Width), 97);
ASSERT ((sy >= 0) & (sy < Height), 97);
ASSERT ((dx >= 0) & (dx < Width), 97);
ASSERT ((dy >= 0) & (dy < Height), 97);
ASSERT ((w >= 0) & ((sx + w) <= Width) & ((dx + w) <= Width), 97);
ASSERT ((h >= 0) & ((sy + h) <= Height) & ((dy + h) <= Height), 97);
as.BeginUpdate;
IF mode = replace THEN term := replaceTerm
ELSIF mode = paint THEN term := paintTerm
ELSE term := invertTerm
END;
rp := as.win.rPort;
gfx.ClipBlit ( rp, MapX (sx), MapY (sy) - h + 1,
rp, MapX (dx), MapY (dy) - h + 1,
w, h, term );
as.EndUpdate;
END CopyBlock;
PROCEDURE CopyPattern*(col: INTEGER; pat: Pattern; x, y, mode: INTEGER);
VAR
rp : gfx.RastPortPtr; bm : gfx.BitMap; p : PatternPtr; term : e.UBYTE;
ignore : BOOLEAN;
BEGIN
IF pat # 0 THEN
ASSERT (as.win # NIL, 97);
ASSERT (mode IN {replace, paint, invert}, 97);
IF (x >= 0) & (x < Width) & (y >= 0) & (y < Width) THEN
as.BeginUpdate;
rp := as.win.rPort;
gfx.SetAPen (rp, SHORT (col)); gfx.SetBPen (rp, 0);
IF mode = replace THEN gfx.SetDrMd (rp, gfx.jam2);
ELSIF mode = paint THEN gfx.SetDrMd (rp, gfx.jam1);
ELSE gfx.SetDrMd (rp, {gfx.complement});
END;
p := SYS.VAL (PatternPtr, pat);
gfx.BltTemplate ( p.raster, 0, (p.W + 7) DIV 8,
rp, MapX (x), MapY (y) - p.h + 1, p.w, p.h );
as.EndUpdate;
END
END
END CopyPattern;
PROCEDURE ReplPattern*
( col : INTEGER; pat : Pattern; x, y, w, h, mode : INTEGER );
VAR rp : gfx.RastPortPtr; p : PatternPtr; x0, y0, W : INTEGER;
BEGIN
ASSERT (as.win # NIL, 97);
ASSERT (mode IN {replace, paint, invert}, 97);
ASSERT (pat # 0);
IF (x >= 0) & (x < Width) & (y >= 0) & (y < Width) THEN
as.BeginUpdate;
rp := as.win.rPort;
gfx.SetAPen (rp, SHORT (col)); gfx.SetBPen (rp, 0);
IF mode = replace THEN gfx.SetDrMd (rp, gfx.jam2);
ELSIF mode = paint THEN gfx.SetDrMd (rp, gfx.jam1);
ELSE gfx.SetDrMd (rp, {gfx.complement});
END;
p := SYS.VAL (PatternPtr, pat);
x := MapX (x); y := MapY (y) - h + 1;
y0 := y;
REPEAT
x0 := x;
REPEAT
gfx.BltTemplate ( p.raster, 0, (p.W + 7) DIV 8,
rp, x0, y0, p.w, p.h );
INC (x0, p.w)
UNTIL x0 >= x + w;
INC (y0, p.h)
UNTIL y0 >= y + h;
as.EndUpdate;
END
END ReplPattern;
PROCEDURE ReplConst*(col, x, y, w, h, mode: INTEGER);
VAR rp : gfx.RastPortPtr;
BEGIN
ASSERT (as.win # NIL, 97);
ASSERT (mode IN {replace, paint, invert}, 97);
IF (x >= 0) & (x < Width) & (y >= 0) & (y <= Height) & (w > 0) & (h > 0)
THEN
ASSERT (w <= (Width - x), 97);
ASSERT (h <= (Height - y), 97);
as.BeginUpdate;
rp := as.win.rPort;
gfx.SetAPen (rp, SHORT (col)); gfx.SetBPen (rp, 0);
IF mode = replace THEN gfx.SetDrMd (rp, gfx.jam2);
ELSIF mode = paint THEN gfx.SetDrMd (rp, gfx.jam1);
ELSE gfx.SetDrMd (rp, {gfx.complement});
END;
x := MapX (x); y := MapY (y) - h + 1;
IF w = 1 THEN (* Drawing a vertical line from (x,y) to (x,y+h-1) *)
gfx.Move (rp, x, y); gfx.Draw (rp, x, y + h - 1)
ELSIF h = 1 THEN (* Drawing a horizontal line from (x,y) to (x+w-1,y) *)
gfx.Move (rp, x, y); gfx.Draw (rp, x + w - 1, y)
ELSE (* Filling a rectangle *)
gfx.RectFill (rp, x, y, x + w - 1, y + h - 1)
END;
as.EndUpdate;
END;
END ReplConst;
PROCEDURE Dot*(col, x, y, mode: INTEGER);
VAR rp : gfx.RastPortPtr; result : BOOLEAN;
BEGIN
ASSERT (as.win # NIL, 97);
ASSERT (mode IN {replace, paint, invert}, 97);
as.BeginUpdate;
rp := as.win.rPort;
gfx.SetAPen (rp, SHORT (col)); gfx.SetBPen (rp, 0);
IF mode = replace THEN gfx.SetDrMd (rp, gfx.jam2);
ELSIF mode = paint THEN gfx.SetDrMd (rp, gfx.jam1);
ELSE gfx.SetDrMd (rp, {gfx.complement});
END;
result := gfx.WritePixel (rp, MapX (x), MapY (y));
as.EndUpdate;
END Dot;
(*raster operations with clipping*)
PROCEDURE CopyBlockC*(F: Frame; sx, sy, w, h, dx, dy, mode: INTEGER);
BEGIN
CopyBlock (sx, sy, w, h, dx, dy, mode)
END CopyBlockC;
PROCEDURE CopyPatternC*(F: Frame; col: INTEGER; pat: Pattern; x, y, mode: INTEGER);
BEGIN
CopyPattern (col, pat, x, y, mode);
END CopyPatternC;
PROCEDURE ReplPatternC*(F: Frame; col: INTEGER; pat: Pattern; x, y, w, h, xp, yp, mode: INTEGER);
BEGIN
ReplPattern (col, pat, x, y, w, h, mode)
END ReplPatternC;
PROCEDURE ReplConstC*(F: Frame; col, x, y, w, h, mode: INTEGER);
BEGIN
ReplConst (col, x, y, w, h, mode)
END ReplConstC;
PROCEDURE DotC*(F: Frame; col, x, y, mode: INTEGER);
BEGIN
Dot (col, x, y, mode)
END DotC;
PROCEDURE* Cleanup ( VAR rc : LONGINT );
VAR pat, next : PatternPtr;
BEGIN (* Cleanup *)
pat := patterns;
WHILE pat # NIL DO
next := pat.next;
gfx.FreeRaster (pat.raster, pat.W, pat.h);
pat := next
END
END Cleanup;
PROCEDURE InitPatterns;
VAR bits : ARRAY 16 OF SET; i : INTEGER;
BEGIN (* InitPatterns *)
FOR i := 0 TO 15 DO bits [i] := {} END;
bits [0] := {20..31}; bits [1] := {22..31};
bits [2] := {24..31}; bits [3] := {24..31};
bits [4] := {22..25,28..31}; bits [5] := {20..23,30..31};
bits [6] := {18..21}; bits [7] := {16..19};
bits [8] := {14..17}; bits [9] := {14..15};
arrow := NewPattern (bits, 18, 10);
FOR i := 0 TO 15 DO bits [i] := {} END;
bits [0] := {20,21}; bits [1] := {12,13,20,21,28,29};
bits [2] := {14,15,20,21,26,27}; bits [3] := {16,17,20,21,24,25};
bits [4] := {18..23}; bits [5] := {10..31};
bits [6] := {18..23}; bits [7] := {16,17,20,21,24,25};
bits [8] := {14,15,20,21,26,27}; bits [9] := {12,13,20,21,28,29};
bits [10] := {20,21};
star := NewPattern (bits, 22, 11);
FOR i := 0 TO 15 DO bits [i] := {} END;
bits [0] := {30,31}; bits [1] := {28..31};
bits [2] := {26..31}; bits [3] := {24..31};
bits [4] := {22..31}; bits [5] := {20..31};
bits [6] := {18..31}; bits [7] := {16..31};
hook := NewPattern (bits, 16, 8);
FOR i := 0 TO 15 DO bits [i] := {} END;
bits [0] := {20,21}; bits [1] := {20,21};
bits [2] := {20,21}; bits [3] := {20,21};
bits [4] := {20,21}; bits [5] := {10..31};
bits [6] := {20,21}; bits [7] := {20,21};
bits [8] := {20,21}; bits [9] := {20,21};
bits [10] := {20,21};
cross := NewPattern (bits, 22, 11);
FOR i := 0 TO 15 DO bits [i] := {} END;
bits [0] := {24,25};
bits [1] := {24,25};
bits [2] := {24,25};
bits [3] := {24,25};
bits [4] := {24,25};
bits [5] := {24,25};
bits [6] := {18,19,24,25,30,31};
bits [7] := {20..29};
bits [8] := {22..27};
bits [9] := {24,25};
downArrow := NewPattern (bits, 14, 10);
FOR i := 0 TO 14 BY 2 DO
bits [i] := {0,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30}
END;
FOR i := 1 TO 15 BY 2 DO
bits [i] := {1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31}
END;
grey0 := NewPattern (bits, 32, 16);
FOR i := 0 TO 14 BY 2 DO
bits [i] := {0,4,8,12,16,20,24,28}
END;
FOR i := 1 TO 15 BY 2 DO
bits [i] := {2,6,10,14,18,22,26,30}
END;
grey1 := NewPattern (bits, 32, 16);
FOR i := 0 TO 12 BY 4 DO
bits [i] := {0,4,8,12,16,20,24,28}
END;
FOR i := 2 TO 14 BY 4 DO
bits [i] := {2,6,10,14,18,22,26,30}
END;
grey2 := NewPattern (bits, 32, 16);
END InitPatterns;
BEGIN
Kernel.SetCleanup (Cleanup);
InitPatterns;
as.OpenDisplay;
Unit := 1; Width := as.W; Height := as.H;
Left := 0; ColLeft := 0; Bottom := 0; UBottom := 0;
END Display.